home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / FILES.SWG / 0066_List all open files.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  13KB  |  465 lines

  1. unit openfiles;
  2. (*
  3.  
  4. OPENFILES - Print list of all open files
  5.  
  6. Written by D.J. Murdoch for the public domain.
  7.  
  8. This unit interfaces three routines, which look in the (undocumented) DOS list
  9. of open files for the filenames.  One routine prints a list of open files,
  10. another returns the list in a collection of strings, and the third calls a
  11. user routine once for each open file.  If compiled for DOS, it automatically
  12. installs an exit handler to call the print routine, so if your program bombs
  13. because it runs out of file handles, you'll see the list of what's open.
  14.  
  15. I've tested this unit in MSDOS 3.2, 4.01, 5 and 6; it should work in the
  16. other versions from 2 to 6, but I'd like to hear from you if it doesn't.
  17.  
  18. Fidonet:   DJ Murdoch at 1:249/99.5
  19. Internet:  dmurdoch@mast.queensu.ca
  20. CIS:       71631,122
  21.  
  22. History:
  23.   1. 21 Oct 91  - First release to PDN echo.
  24.   2. 26 Oct 91  - Added check of PSP segment, and DOS 3.0 record format.
  25.                   Set Allfiles to true to get previous behaviour.
  26.   3. 24 Jun 93  - Added DOS 6 and DPMI support
  27.   4. 24 Aug 94  - Added BP 7 Windows support, a bit more flexibility
  28.                   in ways to call
  29.  
  30. Thanks are due to Berend de Boer for a series of articles explaining how to
  31. make real mode interrupt calls from protected mode.  His hints let me add the
  32. DPMI and Windows support.
  33. *)
  34. {#Z+  Don't add these comments to the help file }
  35.  
  36. interface
  37.  
  38. uses
  39. {$ifdef windows}
  40.   {$ifdef ver15}
  41.   wobjects,winprocs,win31,windos;  { For TPW 1.5 }
  42.   {$else}
  43.   objects,winapi,windos;    { For BP 7 Windows. }
  44.   {$endif}
  45. {$else}
  46. {$ifdef dpmi}
  47.   winapi,           { For BP 7 pmode }
  48. {$endif}
  49.   objects,dos;              { For BP 7 DOS }
  50. {$endif}
  51.  
  52. {#Z-}
  53.  
  54. const
  55.   version = 4;
  56.  
  57.   Allfiles : boolean = false;               { Whether to print files belonging
  58.                                               to other processes }
  59.  
  60. procedure print_open_files(var where:text);
  61. { Print open file list to given file }
  62.  
  63. function get_open_files:PCollection;
  64. { Returns a new collection containing pointers to strings holding the
  65.   filenames.  Note that you'll need to use DisposeStr on each element
  66.   to release them. }
  67.  
  68. procedure For_each_open_file(Action:pointer);
  69. { Calls the far local procedure Action once per open file.  Action should be
  70.   declared as
  71.  
  72.     procedure Action(filename:string;openmode:word); far;
  73.  
  74.   if it's a local procedure, or
  75.  
  76.     procedure Action(filename:string; openmode,dummy:word); far;
  77.  
  78.   if not.  (Local procedures are procedures defined within other procedures.)
  79.   The filename will be the name of the file (no path), the openmode will be the
  80.   mode used to open the file.
  81. }
  82.  
  83. implementation
  84.  
  85. {$ifdef windows}
  86. {$define dpmi}      { Everything else about Windows is
  87.                       the same as DPMI }
  88. {$endif}
  89. type
  90.   ptrrec = record
  91.     ofs, seg : word;
  92.   end;
  93.  
  94. var
  95.   MyPrefixSeg : word;
  96.  
  97. {$ifdef dpmi}
  98.      { This type was given by Berend de Boer, who credited the
  99.        DPMI unit from Borland's Open Architecture book }
  100.      type
  101.        TRealModeRegs = record
  102.          case Integer of
  103.            0: (
  104.                EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
  105.                Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
  106.            1: (
  107.                DI,DIH, SI, SIH, BP, BPH, XX, XXH: Word;
  108.                case Integer of
  109.                  0: (
  110.                      BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
  111.                  1: (
  112.                      BL, BH, BLH, BHH, DL, DH, DLH, DHH,
  113.                      CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
  114.          end;
  115.  
  116. function MakePointer(seg,ofs:word):pointer;
  117. var
  118.   sel,junk : word;
  119. begin
  120.   sel := AllocSelector(Dseg);  { !!4  Copy Dseg attributes }
  121.   sel := SetSelectorBase(sel, longint(16)*seg);
  122.   if sel <> 0 then
  123.   begin
  124.     junk := SetSelectorLimit(sel, $ffff);
  125.     MakePointer := Ptr(sel,ofs);
  126.   end
  127.   else
  128.     MakePointer := nil;
  129. end;
  130.  
  131. procedure ReleasePointer(p:pointer);
  132. var
  133.   junk : word;
  134. begin
  135.   junk := FreeSelector(ptrrec(p).seg);
  136. end;
  137.  
  138. procedure RealModeInterrupt(int:byte;var regs:TRealModeRegs);
  139. label
  140.   okay;
  141. begin
  142.   asm
  143.     mov ax,$0300
  144.     mov bl,int
  145.     mov bh,0
  146.     mov cx,0
  147.     les di,regs
  148.     int $31
  149.     jnc  okay
  150.   end;
  151.   writeln('Real mode call failed!');
  152. okay:
  153. end;
  154.  
  155. function GetListOfLists:pointer;
  156. { Calls DOS service $52 to get pointer to list of lists, and
  157.   translates pointer to a pmode pointer }
  158. var
  159.   regs : TRealModeRegs;
  160. begin
  161.   fillchar(regs,sizeof(regs),0);
  162.   regs.ah := $52;
  163.   RealModeInterrupt($21,regs);
  164.   GetListOfLists := MakePointer(regs.es,regs.bx);
  165. end;
  166.  
  167. procedure GetPrefixSeg;
  168. { Stores real mode segment of the PSP in MyPrefixSeg}
  169. begin
  170.   MyPrefixSeg := GetSelectorBase(system.prefixseg) div 16;
  171. end;
  172. {$else}
  173.  
  174. function MakePointer(seg,ofs:word):pointer;
  175. begin
  176.   MakePointer := Ptr(seg,ofs);
  177. end;
  178.  
  179. procedure ReleasePointer(p:pointer);
  180. begin
  181. end;
  182.  
  183. function GetListOfLists:pointer;
  184. var
  185.   regs : Registers;
  186. begin
  187.   fillchar(regs,sizeof(regs),0);
  188.   regs.ah := $52;
  189.   msdos(regs);
  190.   GetListOfLists := MakePointer(regs.es,regs.bx);
  191. end;
  192.  
  193. procedure GetPrefixSeg;
  194. begin
  195.   MyPrefixSeg := PrefixSeg;
  196. end;
  197.  
  198. {$endif}
  199.  
  200. type
  201.   dos2openfilerec = record
  202.     numhandles,
  203.     openmode : byte;
  204.     junk1 : array[2..3] of byte;
  205.     filename : array[4..$e] of char;
  206.     junk2 : array[$f..$27] of byte;
  207.   end;
  208.  
  209.   dos30openfilerec = record                   {!!2}
  210.     numhandles,
  211.     openmode : word;
  212.     junk1 : array[4..$20] of byte;            {!!2}
  213.     filename : array[$21..$2b] of char;       {!!2}
  214.     junk2 : array[$2c..$31] of byte;          {!!2}
  215.     pspseg : word;                            {!!2}
  216.     junk3 : array[$34..$37] of byte;          {!!2}
  217.   end;
  218.  
  219.   dos3openfilerec = record
  220.     numhandles,
  221.     openmode : word;
  222.     junk1 : array[4..$1f] of byte;
  223.     filename : array[$20..$2a] of char;
  224.     junk2 : array[$2b..$30] of byte;          {!!2}
  225.     pspseg : word;                            {!!2}
  226.     junk3 : array[$33..$34] of byte;          {!!2}
  227.   end;
  228.  
  229.   dos4openfilerec = record
  230.     numhandles,
  231.     openmode : word;
  232.     junk1 : array[4..$1f] of byte;
  233.     filename : array[$20..$2a] of char;
  234.     junk2 : array[$2b..$30] of byte;         {!!2}
  235.     pspseg : word;                           {!!2}
  236.     junk3 : array[$33..$3a] of byte;         {!!2}
  237.   end;
  238.  
  239.   filelistptr = ^filelistrec;
  240.   filelistrec = record
  241.     next : filelistptr;
  242.     numfiles : word;
  243.     case byte of
  244.     2 : (dos2files : array[1..1] of dos2openfilerec);
  245.    30 : (dos30files: array[1..1] of dos30openfilerec);  {!!2}
  246.     3 : (dos3files : array[1..1] of dos3openfilerec);
  247.     4 : (dos4files : array[1..1] of dos4openfilerec);
  248.   end;
  249.  
  250.   Tfilename = String[12];
  251.  
  252. function NiceName(filename:TFilename):TFilename;
  253. var
  254.   result : string;
  255.   blankpos : byte;
  256. begin
  257.   result := filename;
  258.   insert('.',result,9);
  259.   repeat
  260.     blankpos := pos(' ',result);
  261.     if blankpos > 0 then
  262.       delete(result,blankpos,1);
  263.   until blankpos = 0;
  264.   NiceName := result;
  265. end;
  266.  
  267. procedure WalkList(var where:text;C:PCollection;Action:pointer;frame:word);
  268.   procedure Doit(filename:TFilename;openmode:word);
  269.   var
  270.     DoAction : procedure(f:string;openmode:word;dummy:word) absolute Action;
  271.   begin
  272.     filename := NiceName(filename);
  273.     if C <> Nil then
  274.       C^.Insert(NewStr(filename))
  275.     else if Action <> Nil then
  276.       DoAction(filename,openmode,frame)
  277.     else
  278.       writeln(where,filename);
  279.   end;
  280. var
  281.   p : pointer;
  282.   list : filelistptr;
  283.   i : word;
  284. begin
  285.   GetPrefixSeg;                                                  {!!3}
  286.   p := GetListOfLists;                                           {!!3}
  287.   inc(longint(p),4);                                             {!!3}
  288.   if ptrrec(p^).ofs <> $ffff then
  289.     list := MakePointer(ptrrec(p^).seg,ptrrec(p^).ofs)           {!!3}
  290.   else
  291.     list := nil;
  292.   releasePointer(p);                                             {!!3}
  293.  
  294.   while list <> nil do
  295.   begin
  296.     with list^ do
  297.       for i:=1 to numfiles do
  298.         case lo(dosversion) of
  299.         2 : with dos2files[i] do
  300.              if numhandles > 0 then
  301.                doit(filename,openmode);                           {!!4}
  302.         3 : if hi(dosversion) = 0 then                            {!!2}
  303.             begin                                                 {!!2}
  304.               with dos30files[i] do                               {!!2}
  305.                if (numhandles > 0) and (allfiles or               {!!2}
  306.                                         (pspseg = myprefixseg)) then{!!3}
  307.                  doit(filename,openmode)                           {!!4}
  308.             end                                                   {!!2}
  309.             else                                                  {!!2}
  310.               with dos3files[i] do
  311.                if (numhandles > 0) and (allfiles or
  312.                                         (pspseg = myprefixseg)) then{!!3}
  313.                  doit(filename,openmode);                           {!!4}
  314.      4..6 : with dos4files[i] do
  315.              if (numhandles > 0) and (allfiles or                 {!!2}
  316.                                       (pspseg = myprefixseg)) then  {!!3}
  317.                doit(filename,openmode);                             {!!4}
  318.         end;
  319.     p := list;
  320.     if ptrrec(list^.next).ofs <> $ffff then
  321.       list := MakePointer(ptrrec(list^.next).seg,ptrrec(list^.next).ofs) {!!3}
  322.     else
  323.       list := nil;
  324.     ReleasePointer(p);                                            {!!3}
  325.   end;
  326.   ReleasePointer(list);                                           {!!3}
  327. end;
  328.  
  329. procedure print_open_files(var where:text);
  330. { Print open file list to given file }
  331. begin
  332.   WalkList(where,nil,nil,0);
  333. end;
  334.  
  335. function get_open_files:PCollection;
  336. { Returns a new collection containing pointers to strings holding the
  337.   filenames }
  338. var
  339.   result : PCollection;
  340.   junk : text;
  341. begin
  342.   result := New(PCollection,init(16,16));
  343.   if result <> nil then
  344.     WalkList(junk,result,nil,0);
  345.   get_open_files := result;
  346. end;
  347.  
  348. function CallerFrame:word;
  349. Inline(
  350.   $8B/$46/$00/           {   MOV     AX,[BP]}
  351.   $24/$FE);              {   AND     AL,$0FE}
  352.  
  353. procedure For_each_open_file(Action:pointer);
  354. var
  355.   junk : text;
  356. begin
  357.   WalkList(junk,nil,Action,CallerFrame);
  358. end;
  359.  
  360. {$ifndef windows}  { We don't use an exitproc in Windows}
  361.  
  362. var
  363.   exit_save : pointer;
  364.  
  365. procedure my_exit_proc; far;
  366. var
  367.   junk : word;
  368. begin
  369.   ExitProc := Exit_save;
  370.   junk := ioresult;
  371.   assign(output,'');
  372.   rewrite(output);
  373.   writeln('Files open as program terminates:');
  374.   print_open_files(output);
  375. end;
  376. {$endif}
  377.  
  378. begin
  379.   if not (lo(dosversion) in [2..6]) then
  380.     writeln('OPENFILES only works with DOS 2 to 6')
  381. {$ifndef Windows}
  382.   else
  383.   begin
  384.     exit_save := ExitProc;
  385.     ExitProc := @my_exit_proc;
  386.   end
  387. {$endif}
  388. end.
  389.  
  390.  
  391. { ------------------    DEMO PROGRAM ----------------------- }
  392.  
  393. program test;
  394.  
  395. { Test program for Openfiles unit.  Should be compilable in TP/BP 6+, TPW 1.5+ }
  396.  
  397. uses
  398. {$ifdef windows}
  399.   {$ifdef ver15}
  400.   wincrt,wobjects,openfiles;
  401.   {$else}
  402.   wincrt,objects,openfiles;
  403.   {$endif}
  404. {$else}
  405.   objects,openfiles;
  406. {$endif}
  407.  
  408. { This routine uses the callback function "for_each_open_file".  It's the
  409.   only way to get the file open mode. }
  410.  
  411. procedure doit(prefix:string);
  412.   procedure printone(f:string;openmode:word); far;
  413.   begin
  414.     writeln(prefix,f:12,' mode ',openmode);
  415.   end;
  416. begin
  417.   for_each_open_file(@printone);
  418. end;
  419.  
  420. { This routine builds the collection of strings and prints it }
  421.  
  422. procedure doit2(prefix:string);
  423. var
  424.   c:Pcollection;
  425.  
  426.   { Print each filename }
  427.   procedure printone(f:PString); far;
  428.   begin
  429.     writeln(prefix,f^);
  430.   end;
  431.  
  432.   { Release each string }
  433.   procedure disposeone(f:PString); far;
  434.   begin
  435.     DisposeStr(f);
  436.   end;
  437.  
  438. begin
  439.   c:=get_open_files;
  440.   if c <> nil then
  441.   begin
  442.     c^.foreach(@printone);
  443.  
  444.     { This shows the proper way to dispose of the collection }
  445.  
  446.     c^.foreach(@disposeone);
  447.     c^.deleteall;
  448.     dispose(c,done);
  449.   end;
  450. end;
  451.  
  452. var
  453.   f:file;
  454.   i : longint;
  455. begin
  456.   assign(f,'test.pas');
  457.   reset(f);
  458.   allfiles := true;
  459.   doit('Open by some process:  ');
  460.   allfiles := false;
  461.   doit2('Open by us:  ');
  462.  
  463.   { At the end, the exitproc will print one more list (in DOS). }
  464. end.
  465.